home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / DEBUGGER.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  16.3 KB  |  476 lines
  1. ; DEBUGGER.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        System Debugger and Error Handlers            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Oct 1985            *
  16. ;* Revision history:                            *
  17. ;* - 13 Mar 87: Extended errors for DOS I/O errors (tc)            *
  18. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  19. ;* - 08 Jan 93: Added environment-son, pcs-learn-symbols... (mv)    *
  20. ;*                                    *
  21. ;*                    ``In nomine omnipotentii dei''    *
  22. ;************************************************************************
  23.  
  24. ; The following definitions are used only at compile time for readability 
  25. ; and understanding. They will not be written out to the .so file.
  26. ; See miniboot.s and compile.all.
  27.  
  28. (compile-time-alias IO-ERRORS-START 21)
  29. (compile-time-alias IO-ERRORS-END   108)
  30. (compile-time-alias DOS-IO-ERROR    21)
  31. (compile-time-alias FILE-NOT-FOUND  22)
  32. (compile-time-alias PATH-NOT-FOUND  23)
  33. (compile-time-alias TOO-MANY-FILES  24)
  34.  
  35. (define assert-procedure)
  36. (define breakpoint-procedure)
  37. (define error-procedure)
  38. (define *error-handler*)
  39.  
  40. (letrec
  41.  ((uv-msg
  42.      '(1 2 3 4))
  43.   (msg-codes
  44.      '((0 . "Unspecified VM error")
  45.        (1 . "Variable not defined in current environment")
  46.        (2 . "SET! of an unbound variable")
  47.        (3 . "Variable not defined in lexical environment")
  48.        (4 . "SET! of an unbound lexical variable")
  49.        (5 . "Variable not defined in fluid environment")
  50.        (6 . "SET-FLUID! of an unbound fluid variable")
  51.        (7 . "Vector index out of range")
  52.        (8 . "String index out of range")
  53.        (9 . "Invalid substring range")                  ; not generated
  54.        (10 . "Invalid operand to VM instruction")
  55.        (11 . "User keyboard interrupt")
  56.        (12 . "Attempt to call a non-procedural object")
  57.    ;;  (13 . "Engine Timer Interrupt")
  58.        (14 . "I/O attempted to a de-exposed window")
  59.        ;; 14 is a trap for a window handler, not a real error
  60.        (15 . "FLONUM overflow or underflow")
  61.        (16 . "Divide by zero")
  62.        (17 . "Non-numeric operand to arithmetic operation")
  63.        (18 . "Register overflow--Too many arguments to closure")
  64.        (19 . "MAKE-VECTOR size limit exceeded")
  65.        (20 . "MAKE-STRING size limit exceeded")
  66.        (21 . "DOS I/O error number ")
  67.        (22 . "DOS I/O error - File not found")
  68.        (23 . "DOS I/O error - Path not found")        
  69.        (24 . "DOS I/O error - Too many open files")
  70.        (25 . "DOS I/O error - Access denied")
  71.        (32 . "DOS I/O error - Invalid access")
  72.        (36 . "DOS I/O error - Invalid disk drive")
  73.        (39 . "DOS I/O error - Disk write protected")
  74.        (41 . "DOS I/O error - Drive not ready")
  75.        (48 . "DOS I/O error - Printer out of paper")
  76.        (200 . "DOS I/O error - Disk Full")
  77.     ))
  78.   (oops
  79.    (lambda (msg irritant env stk-index kind error-code)
  80.      (fluid-let ((input-port standard-input)
  81.          (output-port standard-output))
  82.        (let* ((si (if (negative? stk-index)
  83.               (%reify-stack (+ (%reify-stack -1) 6))
  84.               stk-index))
  85.           (env (if (null? env)
  86.                (%reify-stack (+ si 9))
  87.                env)))
  88.      (newline)
  89.      (display kind)
  90.      (when msg (display msg))
  91.      (newline)
  92.      (write irritant)
  93.      (newline)
  94.      (pcs-kill-engine)
  95.  
  96.      (if (unbound? compile)
  97.        ;; see if compiler auto-loadable
  98.        (when (not (pcs-autoload-binding 'compile))
  99.          ;; Cant find compiler, punt
  100.          (display (integer->char 7))      ;beep
  101.          (display "Press a key to return to toplevel, escape to exit to DOS")
  102.          (let ((ch (read-char)))
  103.            (if (char=? ch #\escape)
  104.          (exit)
  105.              (scheme-reset))))
  106.      ;else
  107.        (if (null? (%env-lu '%inspector user-initial-environment))
  108.          ;; check to see if we can load the inspector
  109.          (when (or (eqv? *error-message* TOO-MANY-FILES)
  110.                (null? (pcs-autoload-binding '%inspector)))
  111.            (display "Unable to autoload the inspector - file INSPECT.FSL")
  112.            (reset))))    
  113.  
  114.          (%inspector msg kind irritant env si error-code)
  115.  
  116.        ))))
  117.   (envoke-handler
  118.    (lambda (number msg irritant stk-index err-code)
  119.      (let ((handler (lambda ()
  120.                (oops msg 
  121.                  irritant 
  122.                  '() 
  123.                  stk-index 
  124.                      "[VM ERROR encountered!] " 
  125.                  err-code))))
  126.        (if (closure? *user-error-handler*)
  127.       (*user-error-handler* number
  128.                 msg
  129.                 irritant
  130.                 handler)
  131.       (handler)))))
  132.   (decipher-error
  133.    (lambda (stk-index)
  134.      (let  ((err-code *error-code*)
  135.         (irritant *irritant*)
  136.         (err-num (and (number? *error-message*) *error-message*))
  137.         (msg     (apply-if (assv *error-message* msg-codes)
  138.                       cdr
  139.                       *error-message*)))
  140.        (cond ((eqv? err-num 11)                 ; Shift Break
  141.           (set! err-num 100))
  142.              ((and (eqv? err-num 10)            ; BGI graphics errors
  143.            (eqv? (car irritant) '%graphics))
  144.           (if (or (unbound? *pcs-bgi-error*)
  145.               (unbound? *pcs-graphics-error*))
  146.           (set! msg "Unidentified BGI error - *PCS-BGI/GRAPHICS-ERROR* undefined")
  147.           (let ((graph-msg (*pcs-bgi-error*)))
  148.                     (when (not (string-ci=? "No error" graph-msg))
  149.                           (set! msg graph-msg)
  150.               (set! irritant *pcs-graphics-error*)))))
  151.          ((and err-num                    ; I/O Errors
  152.                (>= err-num IO-ERRORS-START)
  153.                (<= err-num IO-ERRORS-END))
  154.           (if (and (or (= err-num FILE-NOT-FOUND)
  155.                        (= err-num PATH-NOT-FOUND))
  156.                    (fluid-bound? *file-exists-open*))
  157.             ((fluid *file-exists-open*) #F))   ; error continuation
  158.  
  159.           (set! err-num (- err-num (-1+ DOS-IO-ERROR)))
  160.           (if (number? msg)
  161.         (set! msg (string-append (cdr (assv DOS-IO-ERROR msg-codes))
  162.                      (integer->string err-num 10))))))
  163.        (envoke-handler err-num msg irritant stk-index err-code))))
  164.   ) ; letrec vars 
  165.  
  166.  (begin
  167.    (set! assert-procedure                ; ASSERT-PROCEDURE
  168.      (lambda (msgs env)
  169.        (oops '() (cons 'ASSERT (cons '() msgs)) env -1 "[ASSERT failure!] " 0)))
  170.  
  171.    (set! breakpoint-procedure                ; BREAKPOINT-PROCEDURE
  172.      (lambda (msg irritant env . rest)
  173.        (let* ((stk-index (if (or (null? rest)
  174.                  (not (integer? (car rest))))
  175.                 -1
  176.                 (car rest))))
  177.          (oops msg irritant env stk-index "[BKPT encountered!] " 0))))
  178.  
  179.    (set! error-procedure                ; ERROR-PROCEDURE
  180.      (lambda (msg irritant env)
  181.        (let ((system-error-handler
  182.            (lambda ()    
  183.                  (oops msg irritant env -1 "[ERROR encountered!] " 0))))
  184.          (if (closure? *user-error-handler*)
  185.        (begin
  186.          (*user-error-handler* '() msg irritant system-error-handler))
  187.      ;else
  188.        (system-error-handler)))))    
  189.  
  190.    (set! *error-handler*                ; *ERROR-HANDLER*
  191.      (lambda ()
  192.        (cond ((eqv? *error-message* 13)            ; special: TIMEOUT_CONDITION
  193.           (if *irritant*
  194.           (mouse 'TRIGGER *irritant*)
  195.           (pcs-engine-timeout)))
  196.          ((and (zero? *error-code*)                 ; resumable
  197.            (memv *error-message* uv-msg))            ; unbound symbol
  198.           (if (pcs-autoload-binding *irritant*)
  199.             '()                                        ; autoload worked!
  200.           ;else
  201.             (let ((info (getprop *irritant* 'PCS*PRIMOP-HANDLER))
  202.               (compiler-present (or (not (unbound? compile))
  203.                         (pcs-autoload-binding 'compile))))
  204.               (cond ((and compiler-present 
  205.                   (integer? info)
  206.                   (getprop *irritant* 'PCS*OPCODE))
  207.                  (let* ((vars '(J I H G F E D C B A))
  208.                     (bvl  (list-tail vars (- (length vars) info)))
  209.                     (form `(define ,*irritant*
  210.                           (lambda ,bvl
  211.                          (,*irritant* . ,bvl))))
  212.                     (dw pcs-display-warnings)
  213.                     (ip pcs-integrate-primitives))
  214.                (set! pcs-display-warnings #F)
  215.                (set! pcs-integrate-primitives #T)
  216.                (eval form user-global-environment)
  217.                (set! pcs-display-warnings dw)
  218.                (set! pcs-integrate-primitives ip)
  219.                '()))
  220.                 ((and compiler-present
  221.                   (pair? info)
  222.                   (eq? (car info) 'DEFINE-INTEGRABLE))
  223.                  (let ((form `(define ,*irritant* ,(cdr info)))
  224.                    (dw pcs-display-warnings)
  225.                    (ip pcs-integrate-primitives))
  226.                (set! pcs-display-warnings #F)
  227.                (set! pcs-integrate-primitives #T)
  228.                (eval form user-initial-environment)
  229.                (set! pcs-display-warnings dw)
  230.                (set! pcs-integrate-primitives ip)
  231.                '()))
  232.                 (else
  233.                  (set! *error-message* 
  234.                    (cdr (assv *error-message* msg-codes)))
  235.                  (*error-handler*))))))
  236.          (else
  237.           (decipher-error (%reify-stack
  238.                      (+ (%reify-stack 
  239.                        (+ (%reify-stack -1) 6)) 6)))))
  240.      ) ;lambda
  241.    ) ;set!
  242.  ) ;begin
  243. ) ;letrec
  244.  
  245. ; autoload infos routines are defined in this file since
  246. ; they are very connected to the error handler.
  247.  
  248. (define autoload-from-file                ; AUTOLOAD-FROM-FILE
  249.   (lambda (file names . rest)
  250.     (let ((env (if rest (car rest) user-initial-environment)))
  251.       (putprop 'PCS-AUTOLOAD-INFO
  252.            (cons (list file names env)
  253.              (getprop 'PCS-AUTOLOAD-INFO
  254.                   'PCS-AUTOLOAD-INFO))
  255.            'PCS-AUTOLOAD-INFO)
  256.       (pcs-learn-symbols names)
  257.       '())))
  258.  
  259.  
  260.  
  261. (define pcs-autoload-binding '())            ; PCS-AUTOLOAD-BINDING
  262. (define remove-autoload-info '())            ; REMOVE-AUTOLOAD-INFO
  263.  
  264. (letrec
  265.   ((find-entry
  266.       (lambda (name info)
  267.     (and info
  268.          (or (symbol? name) (string? name))
  269.          (find-item name (caar info)(cadar info) info))))
  270.    (find-item
  271.       (lambda (name file symbols info)
  272.     (cond ((string? name)
  273.            (if (string-ci=? name file)
  274.              (car info)
  275.          (find-entry name (cdr info))))
  276.           ((null? symbols)
  277.            (find-entry name (cdr info)))
  278.           ((eq? name (car symbols))
  279.            (car info))
  280.           (else
  281.            (find-item name file (cdr symbols) info))))))
  282.     (set! pcs-autoload-binding
  283.       (lambda (name)
  284.         (let* ((info (getprop 'PCS-AUTOLOAD-INFO 'PCS-AUTOLOAD-INFO))
  285.            (entry (find-entry name info)))
  286.       (and entry
  287.            (let ((file (car entry))
  288.              (env  (caddr entry)))
  289.              (and (string? file)
  290.               (file-exists? file)
  291.               (let ((saved-env (%set-global-environment env)))
  292.                 (load file)
  293.                 (%set-global-environment saved-env)
  294.                 (not (null? (%env-lu name env)))
  295.                 )))))))
  296.     (set! remove-autoload-info
  297.       (lambda (filename)
  298.         (let* ((info (getprop 'PCS-AUTOLOAD-INFO 'PCS-AUTOLOAD-INFO))
  299.            (entry (find-entry (%system-file-name filename) info)))
  300.       (and entry
  301.            (putprop 'PCS-AUTOLOAD-INFO
  302.             (delq! entry
  303.                    (getprop 'PCS-AUTOLOAD-INFO
  304.                            'PCS-AUTOLOAD-INFO))
  305.             'PCS-AUTOLOAD-INFO)))))
  306. )
  307.  
  308. (define environment-bindings                ; ENVIRONMENT-BINDINGS
  309.   (letrec
  310.    ((linked-bindings
  311.      (lambda (a-list names values)
  312.        (if (null? names)
  313.        (%reverse! a-list)
  314.        (linked-bindings (cons (cons (car names)(cdr values))
  315.                   a-list)
  316.                 (cdr names)
  317.                 (car values)))))
  318.     (hashed-bindings
  319.      (lambda (a-list index env)
  320.        (if (zero? index)
  321.        a-list
  322.        (let ((bucket (%reify env index)))
  323.          (hashed-bindings (if (null? bucket)
  324.                   a-list
  325.                   (bucket-bindings a-list bucket))
  326.                   (- index 1)
  327.                   env)))))
  328.     (bucket-bindings
  329.      (lambda (a-list bucket)
  330.        (if (null? bucket)
  331.        a-list
  332.        (bucket-bindings (cons (car bucket) a-list)
  333.                 (cdr bucket))))))
  334.    (lambda (obj)
  335.      (if (null? obj)
  336.      obj
  337.      (let* ((env (cond ((environment? obj)        ; environment?
  338.                 obj)
  339.                ((or (closure? obj)        ; closure?
  340.                 (delayed-object? obj))    ; delayed object?
  341.                 (procedure-environment obj))
  342.                (else
  343.                 (%error-invalid-operand 'ENVIRONMENT-BINDINGS
  344.                             obj))))
  345.         (size (%reify env -1)))
  346.        (if (= size 12)
  347.            (linked-bindings '() (%reify env 1) (%reify env 2))
  348.            (hashed-bindings '() (- (quotient size 3) 2) env)))))))
  349.  
  350.  
  351. ;
  352. ; UNBIND is a function which will remove a variable's binding from a given
  353. ; environment. It will work for either of the 2 global environments
  354. ; (USER-GLOBAL-ENVIRONMENT and USER-INITIAL-ENVIRONMENT) or for any other
  355. ; heap allocated environments. Removing the binding from the environment
  356. ; will allow the garbage collector to reclaim that space. Also, once 
  357. ; unbound, the autoloader may reload the variable whenever that variable
  358. ; is referenced again.
  359. ;
  360.  
  361.  
  362. (define unbind
  363.   (letrec 
  364.     ((remove-hashed-binding!        
  365.        (lambda (key alist)
  366.      (cond ((null? (cadr alist))
  367.         '()) 
  368.            ((eq? key (caadr alist))
  369.         (set-cdr! alist (cddr alist)))
  370.            (else
  371.         (remove-hashed-binding! key (cdr alist))))))
  372.      
  373.      (modify-hashed-env!
  374.        (lambda (symbol env)     
  375.          (let* ((hash-val (1+ (%esc 9 (symbol->string symbol))))
  376.                 (sym-list (%reify env hash-val)))
  377.  
  378.        (if (null? sym-list)
  379.          '()
  380.        ;else
  381.          (begin
  382.            (if (eq? symbol (caar sym-list))
  383.           (set! sym-list (cdr sym-list))
  384.            ;else
  385.               (remove-hashed-binding! symbol sym-list))    
  386.                (%reify! env hash-val sym-list)
  387.            env)))))
  388.  
  389.     (remove-linked-binding!
  390.       (lambda (key names values)
  391.      (cond ((null? (cadr names))
  392.         '())
  393.            ((eq? key (cadr names))
  394.                 (set-cdr! names (cddr names))
  395.         (set-car! values (caar values)))
  396.            (else
  397.             (remove-linked-binding! key (cdr names) (car values)))))) 
  398.  
  399.     (modify-linked-env!
  400.       (lambda (symbol env names values)
  401.     (if (eq? symbol (car names))
  402.       (begin
  403.         (set! names (cdr names))
  404.         (set! values (car values)))
  405.     ;else
  406.       (remove-linked-binding! symbol names values))
  407.         (%reify! env 1 names)
  408.         (%reify! env 2 values)))
  409.     )
  410.  
  411.     (lambda (symbol env)
  412.       (cond ((not (symbol? symbol))
  413.              (%error-invalid-operand 'UNBIND symbol))
  414.             ((not (environment? env))
  415.              (%error-invalid-operand 'UNBIND env))
  416.             (else
  417.          (if (= (%reify env -1) 12)
  418.                (modify-linked-env! symbol env (%reify env 1) (%reify env 2))
  419.          ;
  420.            (modify-hashed-env! symbol env)))))))
  421.  
  422.  
  423. (define (procedure-environment obj)            ; PROCEDURE-ENVIRONMENT
  424.   (cond ((closure? obj)
  425.      (%reify obj 1))
  426.     ((delayed-object? obj)
  427.      (procedure-environment (vector-ref obj 1)))
  428.     (else
  429.      (%error-invalid-operand 'PROCEDURE-ENVIRONMENT obj))))
  430.  
  431. (define environment-son                    ; ENVIRONMENT-SON
  432.   (let ((code-block (compile '(make-environment (define obj)))))
  433.     (lambda (env)
  434.       (if (environment? env)
  435.           (let* ((saved-env (%set-global-environment env))
  436.              (result (%execute code-block)))
  437.           (%set-global-environment saved-env)
  438.         (unbind 'obj result)
  439.         result)
  440.           (%error-invalid-operand 'ENVIRONMENT-SON env)))))
  441.  
  442. ; PCS-KNOWN-SYMBOLS-ENVIRONMENT, involved for tab completion,
  443. ; is defined here to recognize auto-loadable symbols.
  444.  
  445. (define pcs-known-symbols-environment            ; PCS-KNOWN-SYMBOLS-ENVIRONMENT
  446.   (environment-son pcs-reserved-symbols-environment))
  447.  
  448. ; The following is an adaptative procedure: if the compiled
  449. ; form is recognized (it should be), it is just "patched", which is much
  450. ; faster than evaluating the whole expression hundreds of times
  451. ; when PCS starts up. Test is performed only during fast-load
  452. ; of this module, of course. (mv)
  453.  
  454. (define pcs-learn-symbols                ; PCS-LEARN-SYMBOLS
  455.   (let* ((code (compile '(set! (access XXX pcs-known-symbols-environment) ())))
  456.          (sym (last-pair (cadddr code)))
  457.          (proc
  458.            (if (eq? (car sym) 'XXX)
  459.          (lambda (name)
  460.            (set-car! sym name)
  461.            (%execute code))
  462.           (lambda (name)
  463.                   (eval `(set! (access ,name pcs-known-symbols-environment) ()))))))
  464.     (lambda (names)
  465.       (for-each proc names))))
  466.  
  467. ; The following closure allows scheme use of incremental symbol lookup
  468.  
  469. (define pcs-recognize-symbol                ; PCS-RECOGNIZE-SYMBOL
  470.   (lambda (str . len)
  471.     (set! len (car len))
  472.     (cond ((eq? str 'done) (%esc 35 -1))
  473.       ((and (string? str) (number? len) (>= len 0) (<= len (string-length str)))
  474.        (%esc 35 str len))
  475.       (else (%error-invalid-operand-list 'pcs-recognize-symbol str len)))))
  476.